home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / yasos < prev   
Text File  |  1993-05-18  |  7KB  |  298 lines
  1. ;; FILE        "YASOS.scm"
  2. ;; IMPLEMENTS    YASOS: Yet Another Scheme Object System
  3. ;; AUTHOR    Kenneth Dickey
  4. ;; DATE     1992 March 1
  5. ;; LAST UPDATED 1992 September 1 -- misc optimizations
  6. ;;          1992 May 22  -- added SET and SETTER
  7.  
  8. ;; REQUIRES     R^4RS Syntax System
  9.  
  10. ;; NOTES: A simple object system for Scheme based on the paper by
  11. ;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
  12. ;; Scheme", Proceedings of the 1988 ACM Conference on LISP and Functional
  13. ;; Programming, July 1988 [ACM #552880].
  14. ;
  15. ;; Setters use space for speed {extra conses for O(1) lookup}.
  16.  
  17.  
  18. ;;
  19. ;; INTERFACE:
  20. ;;
  21. ;; (DEFINE-OPERATION (opname self arg ...) default-body)
  22. ;;
  23. ;; (DEFINE-PREDICATE opname)
  24. ;;
  25. ;; (OBJECT ((name self arg ...) body) ... )
  26. ;;
  27. ;; (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) operation ...)
  28. ;;
  29. ;; in an operation {a.k.a. send-to-super}
  30. ;;   (OPERATE-AS component operation self arg ...)
  31. ;;
  32.  
  33. ;; (SET var new-vale) or (SET (access-proc index ...) new-value)
  34. ;;
  35. ;; (SETTER access-proc) -> setter-proc
  36. ;; (DEFINE-ACCESS-OPERATION getter-name) -> operation
  37. ;; (ADD-SETTER getter setter) ;; setter is a Scheme proc
  38. ;; (REMOVE-SETTER-FOR getter)
  39. ;;
  40.  
  41. ;;;;;;;;;;;;;;;;;;;;;;;;;;;; IMPLEMENTATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42.  
  43. ;; INSTANCES
  44.  
  45. ; (define-predicate instance?)
  46. ; (define (make-instance dispatcher)
  47. ;    (object
  48. ;    ((instance?  self) #t)
  49. ;       ((instance-dispatcher self) dispatcher)
  50. ; )  )
  51.  
  52. (define yasos:make-instance 'bogus)  ;; defined below
  53. (define yasos:instance?     'bogus)
  54. (define-syntax YASOS:INSTANCE-DISPATCHER  ;; alias so compiler can inline for speed
  55.    (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst)))
  56. )
  57.  
  58. (let ( (instance-tag "instance") ) ;; Make a unique tag within a local scope.
  59.                    ;; No other data object is EQ? to this tag.
  60.   (set! YASOS:MAKE-INSTANCE
  61.      (lambda (dispatcher) (cons instance-tag dispatcher)))
  62.  
  63.   (set! YASOS:INSTANCE?
  64.      (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
  65. )
  66.  
  67. ;; DEFINE-OPERATION
  68.  
  69.  
  70. (define-syntax DEFINE-OPERATION
  71.   (syntax-rules ()
  72.     ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
  73.      ;;=>
  74.      (define <name>
  75.        (letrec ( (former-inst #f) ;; simple caching -- for loops
  76.          (former-method #f)
  77.          (self
  78.           (lambda (<inst> <arg> ...)
  79.              (cond
  80.                ((eq? <inst> former-inst) ; check cache
  81.             (former-method <inst> <arg> ...)
  82.                )
  83.                ((and (yasos:instance? <inst>)
  84.                  ((yasos:instance-dispatcher <inst>) self))
  85.               => (lambda (method)
  86.                 (set! former-inst <inst>)
  87.                 (set! former-method method)
  88.                 (method <inst> <arg> ...))
  89.                )
  90.                (else <exp1> <exp2> ...)
  91.            ) ) )  )
  92.     self)
  93.   ))
  94.   ((define-operation (<name> <inst> <arg> ...) ) ;; no body
  95.    ;;=>
  96.    (define-operation (<name> <inst> <arg> ...)
  97.      (slib:error "Operation not handled"
  98.          '<name>
  99.          (format #f (if (yasos:instance? <inst>) "#<INSTANCE>" "~s")
  100.              <inst>)))
  101.   ))
  102. )
  103.  
  104.  
  105.  
  106. ;; DEFINE-PREDICATE
  107.  
  108. (define-syntax DEFINE-PREDICATE
  109.   (syntax-rules ()
  110.     ((define-predicate <name>)
  111.      ;;=>
  112.      (define-operation (<name> obj) #f)
  113.     )
  114. ) )
  115.  
  116.  
  117. ;; OBJECT
  118.  
  119. (define-syntax OBJECT
  120.   (syntax-rules ()
  121.     ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
  122.     ;;=>
  123.      (let ( (table
  124.           (list (cons <name>
  125.               (lambda (<self> <arg> ...) <exp1> <exp2> ...))
  126.               ...
  127.         ) )
  128.       )
  129.       (yasos:make-instance
  130.     (lambda (op)
  131.       (cond
  132.         ((assq op table) => cdr)
  133.         (else #f)
  134. ) ) )))) )
  135.  
  136.  
  137. ;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}
  138.  
  139. (define-syntax OBJECT-WITH-ANCESTORS
  140.   (syntax-rules ()
  141.     ((object-with-ancestors ( (<ancestor1> <init1>) ... ) <operation> ...)
  142.     ;;=>
  143.      (let ( (<ancestor1> <init1>) ...  )
  144.       (let ( (child (object <operation> ...)) )
  145.        (yasos:make-instance
  146.      (lambda (op)
  147.         (or ((yasos:instance-dispatcher child) op)
  148.         ((yasos:instance-dispatcher <ancestor1>) op) ...
  149.        ) )  )
  150.     )))
  151. ) )
  152.  
  153.  
  154. ;; OPERATE-AS  {a.k.a. send-to-super}
  155.  
  156. ; used in operations/methods
  157.  
  158. (define-syntax OPERATE-AS
  159.   (syntax-rules ()
  160.    ((operate-as <component> <op> <composit> <arg> ...)
  161.    ;;=>
  162.     (((yasos:instance-dispatcher <component>) <op>) <composit> <arg> ...)
  163.   ))
  164. )
  165.  
  166.  
  167.  
  168. ;; SET & SETTER
  169.  
  170.  
  171. (define-syntax SET
  172.   (syntax-rules ()
  173.     ((set (<access> <index> ...) <newval>)
  174.      ((yasos:setter <access>) <index> ... <newval>)
  175.     )
  176.     ((set <var> <newval>)
  177.      (set! <var> <newval>)
  178.     )
  179. ) )
  180.  
  181.  
  182. (define yasos:add-setter    'bogus)
  183. (define yasos:remove-setter-for 'bogus)
  184.  
  185. (define YASOS:SETTER
  186.   (let ( (known-setters (list (cons car set-car!)
  187.                   (cons cdr set-cdr!)
  188.                   (cons vector-ref vector-set!)
  189.                   (cons string-ref string-set!))
  190.      )
  191.      (added-setters '())
  192.        )
  193.  
  194.     (set! YASOS:ADD-SETTER
  195.       (lambda (getter setter)
  196.     (set! added-setters (cons (cons getter setter) added-setters)))
  197.     )
  198.     (set! YASOS:REMOVE-SETTER-FOR
  199.       (lambda (getter)
  200.     (cond
  201.       ((null? added-setters)
  202.        (slib:error "REMOVE-SETTER-FOR: Unknown getter" getter)
  203.       )
  204.       ((eq? getter (caar added-setters))
  205.        (set! added-setters (cdr added-setters))
  206.       )
  207.       (else
  208.         (let loop ((x added-setters) (y (cdr added-setters)))
  209.           (cond
  210.         ((null? y) (slib:error "REMOVE-SETTER-FOR: Unknown getter"
  211.                        getter))
  212.         ((eq? getter (caar y)) (set-cdr! x (cdr y)))
  213.         (else (loop (cdr x) (cdr y)))
  214.       ) ) )
  215.      ) ) )
  216.  
  217.     (letrec ( (self
  218.          (lambda (proc-or-operation)
  219.            (cond ((assq proc-or-operation known-setters) => cdr)
  220.              ((assq proc-or-operation added-setters) => cdr)
  221.              (else (proc-or-operation self))) )
  222.         ) )
  223.       self)
  224. ) )
  225.  
  226.  
  227.  
  228. (define (YASOS:MAKE-ACCESS-OPERATION <name>)
  229.   (letrec ( (setter-dispatch
  230.            (lambda (inst . args)
  231.            (cond
  232.              ((and (yasos:instance? inst)
  233.                ((yasos:instance-dispatcher inst) setter-dispatch))
  234.                => (lambda (method) (apply method inst args))
  235.              )
  236.              (else #f)))
  237.         )
  238.         (self
  239.            (lambda (inst . args)
  240.           (cond
  241.              ((eq? inst yasos:setter) setter-dispatch) ; for (setter self)
  242.              ((and (yasos:instance? inst)
  243.                ((yasos:instance-dispatcher inst) self))
  244.               => (lambda (method) (apply method inst args))
  245.              )
  246.              (else (slib:error "Operation not handled" <name> inst))
  247.         )  )
  248.         )
  249.       )
  250.  
  251.       self
  252. ) )
  253.  
  254. (define-syntax DEFINE-ACCESS-OPERATION
  255.   (syntax-rules ()
  256.     ((define-access-operation <name>)
  257.      ;=>
  258.      (define <name> (yasos:make-access-operation '<name>))
  259. ) ) )
  260.  
  261.  
  262.  
  263. ;;---------------------
  264. ;; general operations
  265. ;;---------------------
  266.  
  267. (define-operation (YASOS:PRINT obj port)
  268.   (format port
  269.       ;; if an instance does not have a PRINT operation..
  270.       (if (yasos:instance? obj) "#<INSTANCE>" "~s")
  271.       obj
  272. ) )
  273.  
  274. (define-operation (YASOS:SIZE obj)
  275.   ;; default behavior
  276.   (cond
  277.     ((vector? obj) (vector-length obj))
  278.     ((list?   obj) (length obj))
  279.     ((pair?   obj) 2)
  280.     ((string? obj) (string-length obj))
  281.     ((char?   obj) 1)
  282.     (else
  283.       (slib:error "Operation not supported: size" obj))
  284. ) )
  285.  
  286. (require 'format)
  287.  
  288. ;;; exports:
  289.  
  290. (define print yasos:print)        ; print also in debug.scm
  291. (define size yasos:size)
  292. (define add-setter yasos:add-setter)
  293. (define remove-setter-for yasos:remove-setter-for)
  294. (define setter yasos:setter)
  295.  
  296. (provide 'oop)                ;in case we were loaded this way.
  297. ;;            --- E O F "yasos.scm" ---          ;;
  298.